Sub DataTransfer()

    'Declarations

    Dim source, target As Worksheet
    Dim columns As String
    Dim sourceRow, targetRow As Integer
    Dim sourceCol, targetCol As Integer
    Dim sourceColValue, targetColValue As String
    Dim currentVal As String
       
    'Initialise
   
    Set source = ThisWorkbook.Sheets("Sheet1") ' Source
    Set target = ThisWorkbook.Sheets("Sheet2") ' Target
    columns = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ' 26 column limit

    sourceCol = 1
    sourceRow = 2
    sourceColValue = Mid(columns, sourceCol, 1)
    
    targetCol = 1
    targetRow = 2
    targetColValue = Mid(columns, targetCol, 1)
    
    'Main Loop - until end of data column
    
    While sourceRow <= source.Cells(source.Rows.Count, sourceColValue).End(xlUp).Row
      
        'Save current source value for inner loop
        
        currentVal = source.Range(sourceColValue & sourceRow).Value
        
        ' Always write first records

        target.Range(targetColValue & targetRow).Value = source.Range(sourceColValue & sourceRow).Value
        
        ' Increment source and target column
        
        sourceCol = sourceCol + 1
        sourceColValue = Mid(columns, sourceCol, 1)
                
        targetCol = targetCol + 1
        targetColValue = Mid(columns, targetCol, 1)
        
        ' Write to target
       
        target.Range(targetColValue & targetRow).Value = source.Range(sourceColValue & sourceRow).Value
        
        ' Increment source row and reset column - moves vertically
        
        sourceRow = sourceRow + 1
        sourceCol = 1
        sourceColValue = Mid(columns, sourceCol, 1)
        
        ' Increment target column - moves horizontally
    
        targetCol = targetCol + 1
        targetColValue = Mid(columns, targetCol, 1)
            
        ' Inner Loop ====================
            
        While source.Range(sourceColValue & sourceRow).Value = currentVal
        
            ' Write to target
        
            target.Range(targetColValue & targetRow).Value = source.Range(Mid(columns, sourceCol + 1, 1) & sourceRow).Value
            
            ' Increment source row - moves vertically
        
            sourceRow = sourceRow + 1
            
            ' Increment target row - moves horizontally
    
            targetCol = targetCol + 1
            targetColValue = Mid(columns, targetCol, 1)
            
        Wend ' Inner loop
        
        'Insert rows
        
        targetRow = targetRow + 3
        
        target.Rows(targetRow & ":" & targetRow + 1).Insert Shift:=xlUp
        
        ' Reset source and target
        
        sourceCol = 1
        sourceColValue = Mid(columns, sourceCol, 1)
            
        targetCol = 1
        targetColValue = Mid(columns, targetCol, 1)
                   
     Wend 'Main loop
     
     MsgBox "Reached the end of data in Column A."
     
End Sub